home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / KERNEL4.SEQ < prev    next >
Text File  |  1988-06-28  |  13KB  |  378 lines
  1. \ KERNEL4.SEQ   Last part of the kernel file, finishes up the compile.
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE KERNEL4.SEQ
  8.  
  9. FORTH DEFINITIONS   META IN-META
  10.  
  11. VARIABLE #USER
  12.  
  13. VOCABULARY USER   USER DEFINITIONS
  14.  
  15. : ALLOT         ( n -- ) #USER +!   ;
  16.  
  17. ' CREATE        ( avoid recursion: leave address for ,-X in CREATE )
  18.  
  19. : CREATE        ( -- )
  20.                 [ ,-X ]         \ compile addr of CREATE
  21.                 #USER @ ,
  22.                 ;USES  DOUSER-VARIABLE ,-X
  23.  
  24. : VARIABLE      ( -- ) CREATE   2 ALLOT   ;
  25.  
  26. : DEFER         ( -- ) VARIABLE   ;USES   DOUSER-DEFER  ,-X
  27.  
  28. FORTH DEFINITIONS   META IN-META
  29.  
  30. : >IS           ( cfa -- data-address )
  31.                 DUP 1+ @ OVER >BODY +
  32.                 DUP [  [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP
  33.                 DUP [  [ASSEMBLER] DOUSER-DEFER    META ] LITERAL = SWAP
  34.                 DROP   OR IF   >BODY @ UP @ +   ELSE    >BODY   THEN   ;
  35.  
  36. : (IS)          ( cfa --- ) 2R@SWAP @L >IS !   R> 2+ >R   ;
  37.  
  38. : IS            ( cfa --- ) STATE @
  39.                 IF  COMPILE (IS)  ELSE  ' >IS !  THEN ; IMMEDIATE
  40.  
  41. : SELECT        ( N1 --- )
  42.                 14 bdos drop
  43.                 shndl @ >hndle @ -2 =
  44.                 if      -1 shndl @ >hndle !
  45.                 then    ;
  46.  
  47. : A:            ( --- )         0 SELECT ;
  48. : B:            ( --- )         1 SELECT ;
  49. : C:            ( --- )         2 SELECT ;
  50. : D:            ( --- )         3 SELECT ;
  51.  
  52. : QUIT          ( -- )
  53.                 SP0 @ 'TIB !    [COMPILE] [
  54.                 BEGIN   BEGIN RP0 @ RP! STATUS QUERY  RUN
  55.                               STATE @ NOT UNTIL ."  ok" AGAIN  ;
  56.  
  57. DEFER BOOT
  58. DEFER INITSTUFF   ' SEQINIT IS INITSTUFF
  59. DEFER SEGSET      ' SETYSEG IS SEGSET
  60.  
  61. : WARMSTRT      ( --- )
  62.                 FORTH
  63.                 TRUE ABORT" Warm Start" ;
  64.  
  65. DEFER WARMFUNC  ' WARMSTRT IS WARMFUNC
  66.  
  67. : WARM          ( -- )
  68.                 [ LABEL WARMBODY ]
  69.                 WARMFUNC ;
  70.  
  71. : COLD          ( -- )
  72.                 [ LABEL COLDBODY ]
  73.                 SEGSET VMODE.SET INITSTUFF
  74.                 BOOT QUIT   ;
  75.  
  76. : START         ( -- )
  77.                 SP0 @ 'TIB !
  78.                 >IN OFF
  79.                 SPAN OFF
  80.                 #TIB OFF
  81.                 LOADING OFF
  82.                 DEFAULT INTERPRET ;
  83.  
  84. VARIABLE BIOSBKSAVE     0 ,-T
  85. VARIABLE DIV0SAVE       0 ,-T
  86.  
  87. HEX
  88.  
  89. CODE RESTORE_VECTORS    ( --- )         \ Restores Control BREAK
  90.                 MOV AX, CS              MOV DS, AX
  91.                 MOV DX, CS: BIOSBKSAVE
  92.                 MOV DS, CS: BIOSBKSAVE 2+
  93.                 MOV AX, # 251B
  94.                 INT 21
  95.                 MOV AX, CS              MOV DS, AX
  96.                 MOV DX, CS: DIV0SAVE
  97.                 MOV DS, CS: DIV0SAVE 2+
  98.                 MOV AX, # 2500
  99.                 INT 21
  100.                 MOV AX, CS              MOV DS, AX
  101.                 NEXT                    END-CODE
  102.  
  103. : DIV0STRT      ( --- )
  104.                 TRUE ABORT" Divide OVERFLOW error" ;
  105.  
  106. DEFER DIV0FUNC  ' DIV0STRT IS DIV0FUNC
  107. DEFER BYEFUNC   ' NOOP IS BYEFUNC
  108.  
  109. : BYE           ( -- )
  110.                 BYEFUNC
  111.                 RESTORE_VECTORS
  112.                 CR CR ." Leaving" CR 0 0 BDOS  ;
  113.  
  114. : DIVIDE0       ( STATUS_reg, CS, IP, AX, BX, CX, DX, SI, BP --- )
  115.                 [ LABEL DIV0BODY ]
  116.                 DIV0FUNC BYE ;
  117.  
  118. LABEL DIV0BK    STI             \ Handle a Divide by 0 interupt
  119.                 PUSH AX
  120.                 PUSH BX
  121.                 PUSH CX
  122.                 PUSH DX
  123.                 PUSH SI
  124.                 PUSH DI
  125.                 PUSH BP
  126.                 MOV AX, # DIV0BODY 5 -
  127.                 JMP AX
  128.                 END-CODE
  129.  
  130. LABEL SETBRK    PUSH ES
  131.                 MOV AX, CS
  132.                 MOV DS, AX
  133.                 MOV AX, # AD26          \ Value to restore in >NEXT
  134.                 MOV >NEXT AX            \ Restore it
  135.                 MOV AX, # E0FF          \ Value to restore in >NEXT + 2
  136.                 MOV >NEXT 2+ AX         \ Restore it
  137.                 MOV DX, # BIOSBK
  138.                 MOV AX, # 251B          \ BIOS Break
  139.                 INT 21
  140.                 MOV DX, # DOSBK
  141.                 MOV AX, # 2523          \ DOS Break
  142.                 INT 21
  143.                 MOV DX, # 1
  144.                 MOV AX, # 3301          \ Enable DOS Break
  145.                 INT 21
  146.                 MOV DX, # DIV0BK
  147.                 MOV AX, # 2500          \ BIOS Break
  148.                 INT 21
  149.                 POP ES
  150.                 RET             END-CODE
  151.  
  152. LABEL SAVEVECTORS ( --- )       \ Just save Divide by 0 & Cntrl Brk for now
  153.                 PUSH ES
  154.                 MOV AX, # 351B          \ Get the interupt vector for
  155.                 INT 21                  \ BIOS control break vector
  156.                 MOV BIOSBKSAVE BX
  157.                 MOV BIOSBKSAVE 2+ ES    \ Save old vector
  158.                 MOV AX, # 3500          \ Get the interupt vector for
  159.                 INT 21                  \ DIVIDE by 0
  160.                 MOV DIV0SAVE BX
  161.                 MOV DIV0SAVE 2+ ES      \ Save old vector
  162.                 POP ES
  163.                 RET             END-CODE
  164.  
  165. DECIMAL
  166.  
  167. CODE SET_VECTORS ( --- )
  168.                 CALL SETBRK
  169.                 NEXT            END-CODE
  170.  
  171. [FORTH] ASSEMBLER
  172.  
  173. LABEL WORIG
  174. HERE ORIGIN 6 + - ORIGIN 4 + !-T  ( WARM ENTRY )
  175.         MOV AX, # WARMBODY 5 -
  176.         JMP AX
  177.         END-CODE
  178.  
  179. LABEL CORIG
  180. HERE ORIGIN 3 + - ORIGIN 1+ !-T  ( COLD ENTRY )
  181.         MOV AX, CS                      \ move CS to AX
  182.         MOV DS, AX
  183.         MOV SS, AX
  184.         MOV BX, YSTART                  \ Read YSTART
  185.         OR BX, BX 0<>                   \ If not reset, then move stuff
  186.      IF
  187.         ADD AX, ' #CODESEGS >BODY       \ Add CODE segments and LIST
  188.         ADD AX, ' #LISTSEGS >BODY       \ segments to get to head space.
  189.         MOV ES, AX                      \ move head seg to ES
  190.         MOV CX, YDP
  191.         MOV DI, # 0                     \ Clear DI
  192.         MOV SI, YSTART                  \ MOV YSTART to AX
  193.         OR CX, CX 0<>                   \ if YDP was not zero (0)
  194.         IF      CLD
  195.                 REPZ
  196.                 MOVSB                   \ move HEADS to head space
  197.                 CLD
  198.         THEN
  199.         MOV YSEG ES                     \ set YSEG to ES
  200.      THEN
  201.         MOV BX, XMOVED                  \ Has LIST been moved?
  202.         OR BX, BX 0=                    \ If not reset, then move stuff
  203.      IF
  204.         MOV AX, DS                      \ move DS to AX
  205.         ADD AX, ' #CODESEGS >BODY       \ Add 64k to get to heads
  206.         MOV ES, AX                      \ move head seg to ES
  207.         MOV CX, XSEGLEN
  208.         SHL CX, # 1                     \ MULTIPLY BY 16 DECIMAL
  209.         SHL CX, # 1
  210.         SHL CX, # 1
  211.         SHL CX, # 1
  212.         MOV DI, # 0                     \ Clear DI
  213.         MOV SI, DPSTART                 \ MOV source offset to SI
  214.         OR CX, CX 0<>                   \ if DPSTART was not zero (0)
  215.         IF      CLD             \ Forward move, NOT backwards this time.
  216.                 REPZ
  217.                 MOVSB                   \ move LISTS to LIST space
  218.                 CLD
  219.         THEN
  220.         MOV XSEG ES                     \ set XSEG to ES
  221.      THEN
  222.         CALL SAVEVECTORS                \ Save existing vectors
  223.         CALL SETBRK                     \ Install Break vectors
  224.  
  225.         MOV AX, ' #CODESEGS >BODY
  226.         SUB AX, # 1                     \ One less than max
  227.         SHL AX, # 1
  228.         SHL AX, # 1
  229.         SHL AX, # 1
  230.         SHL AX, # 1
  231.  
  232.         MOV ' LIMIT 3 + AX              \ LIMIT
  233.         SUB AX, # 10
  234.         MOV ' FIRST 3 + AX              \ FIRST = LIMIT - 10h
  235.         SUB AX, # 10
  236.         MOV RP, AX                      \ RP = FIRST - 10h
  237.         MOV BX, # RP0
  238.         ADD BX, UP
  239.         MOV 0 [BX], RP                  \ RP0 = RP
  240.         SUB AX, # 200
  241.         MOV 'TIB AX                     \ TIB = RP - 200 DECIMAL
  242.         MOV BX, # SP0
  243.         ADD BX, UP
  244.         MOV 0 [BX], AX                  \ SP0 = TIB
  245.         MOV SP, AX                      \ SP = TIB
  246.         MOV AX, COLDBODY 2-
  247.         ADD AX, XSEG
  248.         MOV ES, AX
  249.         MOV IP, # 0
  250.         NEXT
  251.         END-CODE
  252.   IN-META
  253.  
  254. HERE UP !-T     ( SET UP USER AREA )
  255.        0 ,      ( TOS )
  256.        0 ,      ( ENTRY )
  257.        0 ,      ( LINK )
  258.        0 ,      ( ES0 )
  259. INIT-R0 256 - , ( SP0 )
  260.  INIT-R0 ,      ( RP0 )
  261.        0 ,      ( DP )          ( Must be patched later )
  262.        0 ,      ( OFFSET )
  263.       10 ,      ( BASE )
  264.        0 ,      ( HLD )
  265.    FALSE ,      ( PRINTING )
  266. ' (EMIT) ,      ( EMIT )
  267. ' (KEY?) ,      ( KEY? )
  268. ' (KEY)  ,      ( KEY  )
  269. ' (TYPE) ,      ( TYPE )
  270. ' (EXTYPE) ,    ( EXTYPE )
  271.  
  272. 0 , 0 , 0 , 0 , 0 ,             \ room for 10 additional USER variables
  273. 0 , 0 , 0 , 0 , 0 ,
  274.  
  275. : DEPTH         ( -- n )   SP@ SP0 @ SWAP - 2/   ;
  276.  
  277. VARIABLE MAX.S
  278.  
  279. : .S            ( -- )    DEPTH 0< ABORT" Stack UNDERFLOW !! "
  280.                 DEPTH ?DUP MAX.S @ 1 < IF 4 MAX.S ! THEN
  281.                 IF      DUP ."  [" 1 .R ." ]" 0 SWAP 1- MAX.S @ 1- MIN
  282.                         DO I PICK 7 U.R BL FEMIT -1 +LOOP
  283.                 ELSE    ."  Stack Empty. "  THEN ;
  284.  
  285. : .ID           ( nfa -- )
  286.                 DUP 1+ DUP YC@ ROT YC@ 31 AND 0
  287.                ?DO      DUP 127 AND FEMIT 128 AND
  288.                         IF   ASCII _ 128 OR   ELSE  1+ DUP YC@  THEN
  289.                 LOOP    2DROP BL FEMIT ;
  290.  
  291. : DUMP          ( addr len -- )
  292.               0 DO   CR DUP 6 .R SPACE  16 0 DO   DUP C@ 3 .R 1+   LOOP
  293.             16 +LOOP   DROP   ;
  294.  
  295. : RECURSE       ( -- ) LAST @ NAME> X,  ;  IMMEDIATE
  296.  
  297. : H.            ( N1 --- ) BASE @ >R HEX U. R> BASE ! ;
  298.  
  299. VARIABLE LMARGIN    0 LMARGIN !-T
  300. VARIABLE RMARGIN   70 RMARGIN !-T
  301. VARIABLE TABSIZE    8 TABSIZE !-T
  302.  
  303. : ?LINE         ( n -- )
  304.                 #OUT @ +  RMARGIN @ > IF CR LMARGIN @ SPACES THEN ;
  305.  
  306. : ?CR           ( -- )  0 ?LINE  ;
  307.  
  308. : TAB           ( --- ) #OUT @ TABSIZE @ MOD TABSIZE @ SWAP - SPACES ;
  309.  
  310. : \             ( --- ) SPAN @ >IN ! ; IMMEDIATE
  311.  
  312. ' (.")                            :RESOLVES <(.")>
  313. ' (")                             :RESOLVES <(")>
  314. ' (;CODE)                         :RESOLVES <(;CODE)>
  315. ' (;USES)                         :RESOLVES <(;USES)>
  316. ' (IS)                            :RESOLVES <(IS)>
  317. ' (ABORT")                        :RESOLVES <(ABORT")>
  318.  [ASSEMBLER] >NEXT    META         RESOLVES <VARIABLE>
  319.  [ASSEMBLER] DOUSER-DEFER META     RESOLVES <USER-DEFER>
  320.  [ASSEMBLER] DOUSER-VARIABLE META  RESOLVES <USER-VARIABLE>
  321.  
  322. ' DEFINITIONS :RESOLVES DEFINITIONS
  323. ' [           :RESOLVES [
  324. ' ?MISSING    :RESOLVES ?MISSING
  325. ' QUIT        :RESOLVES QUIT
  326. ' .ID         :RESOLVES .ID
  327.  
  328. \ Fill in some deferred words
  329. ' CRLF          IS CR
  330. ' NOOP          IS WHERE
  331. ' CR            IS STATUS
  332. ' START         IS BOOT
  333. ' (NUMBER)      IS NUMBER
  334. ' (?ERROR)      IS ?ERROR
  335. ' (PRINT)       IS PEMIT
  336. ' (CONSOLE)     IS CONSOLE
  337.  
  338. ' FORTH >BODY-T CURRENT !-T
  339. ' FORTH >BODY-T CONTEXT !-T
  340.  
  341. HERE-T  DP UP @-T + !-T               ( INIT USER DP )
  342. #USER-T @ #USER !-T                   ( INIT USER VAR COUNT )
  343. TRUE  CAPS !-T                        ( SET TO IGNORE CASE )
  344. TRUE WARNING !-T                      ( SET TO ISSUE WARNINGS )
  345. 31 WIDTH !-T                          ( 31 CHARACTER NAMES )
  346. VOC-LINK-T @ VOC-LINK !-T             ( INIT VOC-LINK )
  347.  
  348. CR .( Unresolved references: )          CR   .UNRESOLVED ?NEWPAGE
  349. CR .(     Statistics: )
  350. CR .( Last  Host Address:        )      [FORTH] HERE U.
  351. CR .( First Target Code Address: )      META 256 THERE U.
  352. CR .( Last  Target Code Address: )      META HERE-T THERE U.
  353.                                         META 256 THERE          \ start addr
  354.                                         SVXSEG     DPSTART !-T
  355.                                         HERE-X DROP 1+
  356.                                         0 XS: DROP - XSEGLEN !-T
  357. CR .( CODE space used:           )      HERE-T U.
  358. CR .( LIST space used:           )      HERE-X SWAP 0 XS: DROP - 16 * + U.
  359. CR .( HEAD space used:           )      HERE-Y U.
  360.                                         HERE-X DROP 1+ 0 XS: DROP -
  361.                                         DUP 16 * ALLOT-T DROP
  362. \                                                      XDPSEG ( UP @-T + ) !-T
  363.                                                         0 XDP ( UP @-T + ) !-T
  364.                                         SVYSEG DUP YSTART !-T
  365.                                         0 XMOVED !-T
  366.                                         HERE-Y +   HERE-Y YDP ( UP @-T + ) !-T
  367.                                         DUP THERE ONLY FORTH ALSO SP@ SWAP -
  368. CR .( Free Symbol Table bytes:   )      U.
  369. ONLY FORTH ALSO
  370.  
  371. .COMPSTAT
  372.  
  373. ( A1 N1 --- )   ZSAVE KERNEL.COM   FORTH
  374.  
  375. CR .( Now type EXTEND <enter> at the DOS prompt.)
  376. CR
  377.  
  378.